EnigmA Amiga Run 1995 November/EnigmA AMIGA RUN 02 (1995)(G.R. Edizioni)(IT)[!][issue 1995-11][Skylink CD].iso/earcd/dbase/scion409.lha/Scion409/ScionARexx.lha/Scion2GEDCOM.rexx

OS/2 REXX Batch file | 1995-10-05 | 18KB | 582 lines

/****************************************************************************
 *                                                                          *
 * $VER: Scion2GEDCOM 2.13 (29 Sep 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 *                                                                          *
 * This program was created to export the Scion data into the GEDCOM file   *
 * format. It should work pretty good by now, although no guarantees        *
 * whatsoever can be given. If you have any problems using this script,     *
 * please describe them to me, as detailed as possible (and please also     *
 * tell me what program you are using to read the GEDCOM file), then I will *
 * try to work out a solution.                                              *
 *                                                                          *
 * GEDCOM was developed by the Family History Department of the Church of   *
 * Jesus Christ of Latter-day Saints to provide a flexible uniform format   *
 * for exchanging computerized genealogical data.  GEDCOM is an acronym for *
 * GEnealogical Data Communication.  GEDCOM is provided to foster the       *
 * sharing of genealogical information and the development of a wide range  *
 * of inter-operable software products to assist genealogists, historians,  *
 * and other researchers.                                                   *
 *                                                                          *
 * This script uses (by default) the rexxreqtools.library (which requires   *
 * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
 * If you do not have these, you need to supply the NOREQ argument (for     *
 * Shell output), or the QUIET argument (for no output at all).             *
 *                                                                          *
 * + Dates should be in English, and in the format "DD MMM YYYY" or         *
 *   "DD-MMM-YYYY", if you don't want any problems with programs importing  *
 *   the GEDCOM data.                                                       *
 *   If the dates in your database are not in English, please run the       *
 *   Translate.rexx script first!                                           *
 * + The database must be running for this AREXX script to work.            *
 *                                                                          *
 * Now with progress indicator, using rexxarplib.library (requested by      *
 * Master Robbie himself :-) )                                              *
 *                                                                          *
 * TO DO (but low priority, unless someone really wants this[?]):           *
 *  - optional creation of external note-files, whenever necessary          *
 *  - If date or place ends with a '?', remove the questionmark and add a   *
 *    QUAY 1 to the data.                                                   *
 *  - Add support for other character sets (now Amiga extended ASCII codes  *
 *    are assumed, even though the GEDCOM format specifies the ANSEL codes  *
 *    as the default)                                                       *
 *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
 *                                                                          *
 ****************************************************************************/

options failat 20; options results
arg outname outval

versionstr = "2.13"
usereq = 1; /* change this to 0 if you don't want to use reqtools */
prgrs = 1; pgopen = 0; /* use RexxArp progress indicator */
  /* change prgrs to 0 for not using it */
outp = 1; output = stdout
NL = '0A'x

signal on IOERR

/* parse command line options, to enable calling the script automatically,
 * eg. from a function key
 */

do while outname = '?'
  writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S ")
  pull outname outval
end

if outname ~= "" then do
  if outname = "QUIET" | outname = "NOREQ" then do
    outval = outname; outname = ""
  end
end

if outval = "QUIET" then do
  outp = 0; usereq = 0; prgrs = 0
end
else if outval = "NOREQ" then do
  usereq = 0; prgrs = 0
end

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

if ~usereq then prgrs = 0

if prgrs & ~show('l','rexxarplib.library') then do
  if exists('libs:rexxarplib.library') then
    call addlib('rexxarplib.library',0,-30,0)
  else
    prgrs = 0
end

/* These first few lines are stolen from Peter Billings - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  TermError('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

MyPort = "SCIONGEN"
Address value MyPort
GETDBNAME
dbname = upper(RESULT)

if outp & ~usereq then do
  Tell("Scion to GEDCOM conversion script v"||versionstr||" by Freddy Ariës")
  Tell("Database: "||dbname|| NL)
end

/* It's a good habit to add the ".scion" extension to Scion database files */
dblen = length(dbname)
if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)

if outname = "" then do
  if outp then do
    if usereq then do
      odev = rtezrequest('Current Scion database: '||dbname||,
       NL||'Where should the GEDCOM output be sent to?'||,
       NL,' _File |_Printer|_Screen|_Nowhere','Scion to GEDCOM v'||versionstr||' by Freddy Ariës','rt_pubscrname = SCIONGEN')
      select
        when odev = 1 then do
          /* We need a file requester for further data */
          outname = rtfilerequest(,dbname||'.GED','Output filename',,'rtfi_buffer = true   rt_pubscrname = SCIONGEN   rtfi_initialpath = RAM:',)
          if outname = '' then
            outname = dbname||'.GED'
        end
        when odev = 2 then
          outname = 'PRT:'
        when odev = 3 then
          outname = 'STDOUT'
        otherwise
          EXIT
          /* You selected 'Nowhere' */
      end
    end
    else do
      Tell("Enter output file (filename with complete path, or PRT: for printer,")
      TellNN("or STDOUT for screen): ")
      pull outname
      Tell("Destination: "||outname)
      TellNN("Continue (y/n)? ")
      pull conf
      /* Note that left works on empty strings ("") too! */
      if left(conf,1) ~= "Y" then do
        Tell("Goodbye...")
        EXIT
      end
      Tell("")
    end
  end
  else
    outname = "RAM:"dbname".GED"
    /* If we're not allowed to use stdout, default to this filename */
end

if outname ~= "STDOUT" then do
  output = 'OUTPUT'
  if ~open(output, outname, "w") then
    TermError("ERROR: Unable to open output file.")
end

if ~usereq then
  Tell("Be patient - this may take a while...")

GETPROGVERSION
prgvers = RESULT

writeln(output, "0 HEAD")
writeln(output, "1 SOUR SCION_AMIGA")
writeln(output, "2 NAME Scion Genealogist")
writeln(output, "2 VERS "||prgvers)
writeln(output, "2 CORP Robbie J. Akins")
writeln(output, "3 ADDR 5 Austin Street, Wellington 6001, New Zealand")

str = "1 DATE" upper(date())
writeln(output, str)
writeln(output, "1 @S1@ SUBM")
str = "1 FILE" dbname
writeln(output, str)
writeln(output, "1 GEDC")
writeln(output, "2 VERS 5.3")
writeln(output, "1 CHAR 8-bit Extended ASCII (AMIGA)")

if prgrs then do
  Postmsg(10, 10, "Scion to GEDCOM (by Freddy Ariës)\Database: "||dbname||"\Processing person:\ ", "SCIONGEN")
  pgopen = 1
end

GETTOTALIRN
TotalIRN = RESULT
do i = 1 to TotalIRN
  if pgopen then Postmsg(,,"\\\"||i||" (of "||TotalIRN||")", "SCIONGEN")
  EXISTPERSON i
  if RESULT = 'YES' then
  do
    str = "0 @I"i"@ INDI"
    writeln(output, str)
    GETFIRSTNAME i
    fnames = RESULT
    fnames = translate(fnames, ';', '/')
    /* Fixed since v2.13: no '/' characters allowed in GEDCOM namestring! */
    GETLASTNAME i
    lname = RESULT
    lname = translate(lname, ';', '/')
    str = "1 NAME "fnames"/"lname"/"
    writeln(output, str)
    GETSEX i
    sx = RESULT
    if sx ~= "M" then do
     sx = "F"
    end
    str = "1 SEX" sx
    writeln(output, str)
    GETBIRTHDATE i
    datestr = ParseDate(upper(RESULT))
    GETBIRTHPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 BIRT")
      if datestr ~= "" then do
        str = "2 DATE" datestr
        writeln(output, str)
      end
      if placestr ~= "" then do
        str = "2 PLAC" placestr
        writeln(output, str)
      end
    end
    GETBAPTISMDATE i
    datestr = ParseDate(upper(RESULT))
    GETBAPTISMPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 BAPM")
      if datestr ~= "" then do
        str = "2 DATE" datestr
        writeln(output, str)
      end
      if placestr ~= "" then do
        str = "2 PLAC" placestr
        writeln(output, str)
      end
    end
    GETDEATHDATE i
    datestr = ParseDate(RESULT)
    GETDEATHPLACE i
    placestr = RESULT
    GETDIEDOF i
    diedofstr = RESULT
    if datestr ~= "" | placestr ~= "" | diedofstr ~= "" then do
      writeln(output, "1 DEAT")
      if datestr ~= "" then do
    str = "2 DATE" datestr
    writeln(output, str)
      end
      if placestr ~= "" then do
    str = "2 PLAC" placestr
    writeln(output, str)
      end
      if datestr ~= "" then do
    str = "2 CAUS" diedofstr
    writeln(output, str)
      end
    end
    GETBURIALDATE i
    datestr = ParseDate(RESULT)
    GETBURIALPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 BURI")
      if datestr ~= "" then do
    str = "2 DATE" datestr
    writeln(output, str)
      end
      if placestr ~= "" then do
    str = "2 PLAC" placestr
    writeln(output, str)
      end
    end
    GETOCCUPATION i
    rs1 = RESULT
    if rs1 ~= "" then do
      str = "1 OCCU" rs1
      writeln(output, str)
    end
    GETEDUCATION i
    rs1 = RESULT
    if rs1 ~= "" then do
      str = "1 EDUC" rs1
      writeln(output, str)
    end
    GETRELIGION i
    rs1 = RESULT
    if rs1 ~= "" then do
      str = "1 RELI" rs1
      writeln(output, str)
    end
    GETPERSCOMMENT i
    rs1 = RESULT
    GETPERSREFS i
    rs2 = RESULT
    if rs1 ~= "" then do
      str = "1 NOTE" rs1
      writeln(output, str)
    end
    else if rs2 ~= "" then do
      /* We need some way to separate the Comments data from the
       * References data - (ab)use the NOTE and CONT fields for that
       */
      str = "1 NOTE -"
      writeln(output, str)
    end
    if rs2 ~= "" then do
      str = "2 CONT" rs2
      writeln(output, str)
    end
    GETPARENTS i
    ParFGRN = RESULT
    EXISTFAMILY ParFGRN
    if RESULT = 'YES' then do
      str = "1 FAMC @F"ParFGRN"@"
      writeln(output, str)
    end
    HuwNum = 0
    GETMARRIAGE i HuwNum
    MarrFGRN = RESULT
    do while MarrFGRN ~= ""
      EXISTFAMILY MarrFGRN
      if RESULT = 'YES' then do
        str = "1 FAMS @F"MarrFGRN"@"
        writeln(output, str)
      end
      HuwNum = HuwNum + 1
      GETMARRIAGE i HuwNum
      MarrFGRN = RESULT
    end
  end
end
if ~usereq then
  Tell("Number of persons output: "||TotalIRN)

/* Now the list of families... */

if pgopen then Postmsg(,, "\\Processing family:\ ", "SCIONGEN")

GETTOTALFGRN
TotalFGRN = Result
do i = 1 to TotalFGRN
  if pgopen then Postmsg(,, "\\\"||i||" (of "||TotalFGRN||")", "SCIONGEN")
  EXISTFAMILY i
  if RESULT = 'YES' then do
    str = "0 @F"i"@ FAM"
    writeln(output, str)
    GETPRINCIPAL i
    husb = RESULT
    if husb ~= "" then do
      EXISTPERSON husb
      if RESULT = 'YES' then do
    GETSEX husb
    hsx = RESULT
    /* Note: GEDCOM requires 1 husband (male) and 1 wife (female).
     * Scion allows more unconventional matings as well, so we have
     * to improvise a bit here, and hope the receiving program isn't
     * too strict...
     */
    if hsx = "M" then do
      str = "1 HUSB @I"husb"@"
      writeln(output, str)
      GETSPOUSE i
      wife = RESULT
      if wife ~= "" then do
        EXISTPERSON wife
        if RESULT = 'YES' then do
          /* The principal is male; assume the partner is female */
          str = "1 WIFE @I"wife"@"
          writeln(output, str)
        end
      end
    end
    else do
      /* The principal isn't male - define the partner as male
         and the principal as female
       */
      if hsx ~= "F" then do
            if usereq then
          rtezrequest('WARNING: Unrecognized Sex for Principal'||NL||,
                'Sex was:'||hsx||'. Assuming FEMALE!','_Continue','Converter Message:','rt_pubscrname = SCIONGEN')
            else
          Tell("WARNING: Unrecognized Sex for Principal ("||hsx||") - assuming FEMALE")
      end
      GETSPOUSE i
      wife = RESULT
      if wife ~= "" then do
        EXISTPERSON wife
        if RESULT = 'YES' then do
          GETSEX wife
          hsx = RESULT
          if hsx ~= "M" then do
            if usereq then
              rtezrequest('WARNING: No male partner in family!','_Continue','Converter Message:','rt_pubscrname = SCIONGEN')
                else
          Tell("WARNING: No male partner in family!")
              end
          str = "1 HUSB @I"wife"@"
          writeln(output, str)
        end
      end
      str = "1 WIFE @I"husb"@"
      writeln(output, str)
    end
      end
    end
    GETENGAGEDATE i
    datestr = ParseDate(RESULT)
    GETENGAGEPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 ENGA")
      if datestr ~= "" then do
        str = "2 DATE" datestr
    writeln(output, str)
      end
      if placestr ~= "" then do
    str = "2 PLAC" placestr
    writeln(output, str)
      end
    end
    datestr = ""; placestr = ""
    GETMARRYDATE i
    datestr = ParseDate(RESULT)
    GETMARRYPLACE i
    placestr = RESULT
    GETCELEBRANT
    clbrnt = RESULT
    if datestr ~= "" | placestr ~= "" | clbrnt ~= "" then do
      writeln(output, "1 MARR")
      if datestr ~= "" then do
        str = "2 DATE" datestr
    writeln(output, str)
      end
      if placestr ~= "" then do
    str = "2 PLAC" placestr
    writeln(output, str)
      end
      if clbrnt ~= "" then do
    str = "2 OFFI" clbrnt
    writeln(output, str)
      end
    end
    GETENDING i
    endstr = RESULT
    if endstr = "2" | endstr = "3" | endstr = "4" then do
      if endstr = "2" then do
        writeln(output, "1 DIV")
        writeln(output, "2 TYPE DIVORCED")
      end
      else if endstr = "3" then do
        writeln(output, "1 DIV")
        writeln(output, "2 TYPE SEPARATED")
      end
      else if endstr = "4" then
        writeln(output, "1 ANUL")
      datestr = ""; placestr = ""
      GETENDDATE i
      datestr = ParseDate(RESULT)
      if datestr ~= "" then do
        str = "2 DATE" datestr
    writeln(output, str)
      end
      GETENDPLACE i
      placestr = RESULT
      if placestr ~= "" then do
    str = "2 PLAC" placestr
    writeln(output, str)
      end
      /* TO DO: how do we convert an enddate/place caused by death ? */
    end
    GETFAMREFS i
    rs1 = RESULT
    GETFAMCOMMENT i
    rs2 = RESULT
    if rs2 ~= "" then do
      str = "1 NOTE" rs2
      writeln(output, str)
    end
    else if rs1 ~= "" then do
      /* We need some way to separate the Reference data from the
       * Comments data - (ab)use the NOTE and CONT fields for that
       */
      str = "1 NOTE -"
      writeln(output, str)
    end
    if rs1 ~= "" then do
      str = "2 CONT" rs1
      writeln(output, str)
    end

    ChNum = 0
    GETCHILD i ChNum
    ChIRN = RESULT
    do while ChIRN ~= ""
      EXISTPERSON ChIRN
      if RESULT = 'YES' then do
        str = "1 CHIL @I"ChIRN"@"
        writeln(output, str)
      end
      ChNum = ChNum + 1
      GETCHILD i ChNum
      ChIRN = RESULT
    end
    /* optional:
       str = "1 NCHI" ChNum
       writeln(output, str)
     */
  end
end
if pgopen then do
  Postmsg()
  pgopen = 0
end
if usereq then
  rtezrequest('Conversion done.'||NL||'Number of persons output: '||TotalIRN||,
    NL||'Number of families output: '||TotalFGRN||NL,'_Continue','Converter Message:','rt_pubscrname = SCIONGEN')
else
  Tell("Number of families output: "||TotalFGRN)

writeln(output, "0 TRLR")
close('OUTPUT')
EXIT

ParseDate: PROCEDURE
parse arg datestr

/* optional: remove leading zero's */
/* replace all "-" or "/" in the date by " " */
datestr = upper(translate(datestr,'  ','-/'))
/* replace ABOUT by ABT, BEFORE by BEF and AFTER by AFT */
if left(datestr, 5) = "ABOUT" then
  datestr = "ABT"||right(datestr,length(datestr)-5)
else if left(datestr, 6) = "BEFORE" then
  datestr = "BEF"||right(datestr,length(datestr)-6)
else if left(datestr, 5) = "AFTER" then
  datestr = "AFT"||right(datestr,length(datestr)-5)
return datestr

Tell: PROCEDURE EXPOSE outp
parse arg str
if outp then writeln(stdout, str)
return 0

TellNN: PROCEDURE EXPOSE outp
parse arg str
if outp then writech(stdout, str)
return 0

TermError: PROCEDURE EXPOSE outp output usereq pgopen
parse arg str
if pgopen then Postmsg()
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = SCIONGEN')
else
  Tell(str || '0A'x)
close(output)
EXIT

/* Let's make sure you get a nice message when you turn off the printer :-) */

IOERR:
  bline = SIGL
  say "I/O error #"||RC||" detected in line "||bline||":"
  say sourceline(bline)
  if pgopen then Postmsg()
  EXIT